VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsFileError"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
'some arb change
Public Function CreateErrorFile(lngInterfaceNo As Long, strErrorType As String, Optional strFmtErrCode As String, Optional strFmtErrReason As String, _
                                Optional strFmtErrLine As String, Optional strFmtErrText As String, Optional strFailReason As String) As Boolean

    Dim strTempFile As String
    Dim strXmlHeader As String
    Dim strXmlVersDtdHeader As String
    Dim strXmlError As String
    Dim lngNewInterfaceNo As Long
    Dim strNewMsgId As String
    Dim strOraMsg As String

    Set objFileError = New clsFileError
    Set objFunctions = New clsErrorFunctions
    
    
    ClearIdxVars
    
    'Get Variables
    ErrVars.InterfaceNo = lngInterfaceNo
    ErrVars.ErrorType = strErrorType
    Select Case ErrVars.ErrorType
        Case "01"
            ErrVars.FormatErr.Code = strFmtErrCode
            ErrVars.FormatErr.Line = strFmtErrLine
            ErrVars.FormatErr.Reason = strFmtErrReason
            ErrVars.FormatErr.Text = strFmtErrText
        Case "02"
            'ErrVars.DataErr.DataErrText = strFmtErrText
            ErrVars.FormatErr.Text = strFmtErrText
        Case Else
            strFailReason = "Invalid ErrorType: " & ErrVars.ErrorType
            CreateErrorFile = False
            Exit Function
    End Select
    
    If objFunctions.ValidateErrorFileData(strFailReason) Then
    
        If Not ConnectToDb(strOraMsg) Then
            WriteToErr "Error connecting to database: " & strOraMsg
            Exit Function
        End If
        
        If objFunctions.ExtractIndexBlobFromDb(ErrVars.InterfaceNo) = True Then
            If ErrVars.ErrorType = "02" Then
                If objFunctions.ValidateXmlFormat(strFailReason) Then
                    If objFunctions.GetHeaderData Then
                        If objFunctions.ValidateHeaderData(strFailReason) Then
                            strXmlHeader = objFunctions.CreateXmlHeader
                        Else
                            CreateErrorFile = False
                            strFailReason = "Invalid Header Data: " & strFailReason
                            Exit Function
                        End If
                    Else
                        CreateErrorFile = False
                        strFailReason = "Error occurred while Getting the Header information."
                        Exit Function
                    End If
                Else
                    CreateErrorFile = False
                    strFailReason = "XmlErrorFormat: " & strFailReason
                    Exit Function
                End If
            Else
                '01 = FileFormat error - can't open file via XML - read text to get header
                strXmlHeader = GetHeaderFromText
'                If objFunctions.ValidateHeaderData(strFailReason) = False Then
'                    strXmlHeader = ""
'                End If
            End If
        Else
            CreateErrorFile = False
            strFailReason = "Interface Number not found: " & ErrVars.InterfaceNo
            Exit Function
        End If
    Else
        CreateErrorFile = False
    End If
    
    If Len(Trim(strXmlHeader)) <> 0 Then
        'produce error file
        strXmlVersDtdHeader = objFunctions.CreateXmlVersionDtdHeader
        If objFunctions.CreateFileError(strXmlHeader, strFailReason, strXmlError) Then
            'BARB: DECIDE WHETHER TO KEEP TRANS STUFF OR NOT
            adoConn.BeginTrans
            If objFunctions.InsertIntoInterfaceIndex(lngNewInterfaceNo, strNewMsgId) Then
                If objFunctions.InsertIntoInterfaceXml(lngNewInterfaceNo, strNewMsgId, strXmlVersDtdHeader, strXmlError) Then
                    'flag original index no as error (06) so that receive doesn't pick it up again
                    If objFunctions.UpdateInterfaceIndex Then
                        adoConn.CommitTrans
                        CreateErrorFile = True
                    Else
                        adoConn.RollbackTrans
                        CreateErrorFile = False
                    End If
                Else
                    adoConn.RollbackTrans
                    CreateErrorFile = False
                End If
            Else
                CreateErrorFile = False
            End If
        Else
            CreateErrorFile = False
        End If
    End If
        
End Function

Public Function XMLTest() As Boolean
    
'use this to test input
'send in temp file to copy image to from db
'this is where we go get the segments stored in the db and glue them together
'still need to loop thru db and find a way to view/display each file

     Dim rsBlob As ADODB.Recordset
     Dim arrBlob() As Byte
     Dim iFree As Integer
     Dim lngBlobLen As Long
     Dim lngRemainder As Long
     Dim lngNumOfSections As Long
     Dim strSql As String
     Dim BlobHolder As Variant
     Dim i As Integer
     Dim strTemp As String

     Const SEGMENT_LENGTH As Long = 4096

    On Error GoTo XmlTestFix

     iFree = FreeFile

     'initilize the recordset
     Set rsBlob = New ADODB.Recordset
     rsBlob.CursorType = adOpenKeyset
     rsBlob.LockType = adLockOptimistic
     'rsBlob.open "select * from VCO_LONGRAW_IMAGES where VLI_VSM_ID = '" & strID & "' and VLI_PAGE_NO = " & strPageNo, objAdoConn.Connection
     
    'strSql = "Select XML_STRING from DIR_INTERFACE_INDEX I, DIR_INTERFACE_XML X"
    strSql = "Select * from DIR_INTERFACE_INDEX I, DIR_INTERFACE_XML X"
    strSql = strSql & " where I.MQ_STATUS = '01'"
    strSql = strSql & " and I.INTERFACE_NO = X.INTERFACE_NO"
    strSql = strSql & " and I.MESSAGE_ID = X.MESSAGE_ID"
    Set rsBlob = adoConn.Execute(strSql)
     
     
'     rsBlob.MoveFirst
'
'     'get the length of the blob
'     lngBlobLen = rsBlob!XML_STRING.ActualSize
'
'     'get the number of sections that will be the number of elements in the sections array
'     lngNumOfSections = lngBlobLen \ SEGMENT_LENGTH
'
'     'get the leftover bytes that aren't divisible by the section_length
'     lngRemainder = lngBlobLen Mod SEGMENT_LENGTH
'
'     If lngRemainder <> 0 Then 'add the remaider
'         arrBlob = rsBlob(0).GetChunk(lngRemainder)
'     End If


    rsBlob.MoveFirst
     
     'barb: get idx vars here
     'IdxVars.

     'get the length of the blob
     lngBlobLen = rsBlob!XML_STRING.ActualSize

     'get the number of sections that will be the number of elements in the sections array
     lngNumOfSections = lngBlobLen \ SEGMENT_LENGTH

     'get the leftover bytes that aren't divisible by the section_length
     lngRemainder = lngBlobLen Mod SEGMENT_LENGTH

     If lngRemainder <> 0 Then 'add the remaider
         'arrBlob = rsBlob(0).GetChunk(lngRemainder)
         arrBlob = rsBlob!XML_STRING.GetChunk(lngRemainder)
     End If

    Dim strNewFilename As String
    strNewFilename = "C:\temp\XmlTest\1.txt"

     If Dir(strNewFilename) <> "" Then
         Kill strNewFilename
     End If

     'open the new file to put the data into
     Open strNewFilename For Binary Access Write As iFree

         'put the remainder first
         Put iFree, , arrBlob
         strTemp = CStr(arrBlob)

         'loop for the rest
         For i = 1 To lngNumOfSections
             'arrBlob = rsBlob(0).GetChunk(SEGMENT_LENGTH)
             arrBlob = rsBlob!XML_STRING.GetChunk(SEGMENT_LENGTH)
             'strTemp = strTemp & CStr(arrBlob(i - 1))
             strTemp = strTemp & CStr(arrBlob)
             Put iFree, , arrBlob
         Next

         Close iFree

     rsBlob.Close

    Debug.Print strTemp

    XMLTest = True

    Exit Function
    
XmlTestFix:
    WriteToErr "XmlTest: " & Err.Number & " - " & Err.Description
    XMLTest = False
End Function


    

'Public Function GetHeaderFromText() As String
'
'    Dim strHeader As String
'    Dim strTemp1 As String
'    Dim strTemp2 As String
'    Dim lPos As Long
'    Dim strTypeOfRequest As String
'    Dim rsTemp As ADODB.Recordset
'    Dim strSql As String
'
'
'    On Error GoTo GetHeaderFromTextFix
'
'    lPos = InStr(1, IdxVars.XmlString, "</Tracking>")
'    If lPos <> 0 Then
'        'get text up til end of header then close root node
'        strHeader = Mid(IdxVars.XmlString, 1, lPos + 11)
'        strTemp1 = strHeader
'        'remove version & dtd line
'        lPos = InStr(1, strTemp1, ".dtd") + 8
'        If lPos > 0 Then
'            'works if bus unti = 'LCB'
'            'strTemp2 = Mid(strTemp1, lPos - 2, Len(strTemp1) - lPos)
'            'works if bus unti = 'LCB01'
'            strTemp2 = Mid(strTemp1, lPos - 2, Len(strTemp1))
'        End If
'        'change KeyTax Type to "10" for error
'        lPos = InStr(1, strTemp2, "<KeyTax Type=") + 13
'        If lPos > 0 Then
'            Select Case IdxVars.KeyTaxType
'                Case "01", "03", "07", "08"
'                Case Else
'                    IdxVars.KeyTaxType = Mid(strTemp2, lPos + 1, 2)
'            End Select
'            strTemp1 = Mid(strTemp2, 1, lPos) & "" & "10" & """"
'            strTemp1 = strTemp1 & Mid(strTemp2, lPos + 4, Len(strTemp2))
'        End If
'        'change the Request Status to "15" for error
'        'lPos = InStr(1, strTemp1, "<RequestStatus Type=") + 20
'        strSql = "Select MEANING from DIR_SYSTEM_CODES where VALUE = 15 and CODE = 'DIR_REQ_STATUS'"
'        Set rsTemp = adoConn.Execute(strSql)
'        If rsTemp.RecordCount <= 0 Then
'            MsgBox "GetHeaderFromText: Data does not exist in the database: " & strSql
'            GetHeaderFromText = ""
'            Exit Function
'        Else
'            strTypeOfRequest = rsTemp!MEANING
'        End If
'        lPos = InStr(1, strTemp1, "<RequestStatus>") - 1
'        If lPos > 0 Then
'            strTemp1 = Left(strTemp1, lPos + 15)
'            lPos = InStr(1, strHeader, "</RequestStatus>")
'            strTemp2 = Mid(strHeader, lPos, Len(strHeader) - lPos)
'            'strTemp2 = Mid(strTemp1, 1, lPos) & "" & strTypeOfRequest & """"
'            'strTemp2 = strTemp2 & Mid(strTemp1, lPos + 4, Len(strTemp1))
'        End If
'
'        'strTemp2 = strTemp2 & "</KeyTax>"
'        'strTemp2 = strTemp2 & "</KeyTax>"
'
'        'for testingonly: forcing BusUnit = "LCB01"
'        'strTemp2 = Left(strTemp2, 55) & "01" & Right(strTemp2, Len(strTemp2) - 55)
'
'        GetHeaderFromText = strTemp1 & strTypeOfRequest & strTemp2 & "</KeyTax>"
'        'GetHeaderFromText = strTemp1 & strTypeOfRequest & "</KeyTax>"
'        'GetHeaderFromText = strTemp1
'    Else
'        GetHeaderFromText = ""
'    End If
'
'    Exit Function
'
'GetHeaderFromTextFix:
'    WriteToErr "GetHeaderFromText: " & Err.Number & " - " & Err.Description
'    GetHeaderFromText = ""
'End Function
Public Function GetHeaderFromText() As String

    Dim strHeader As String
    Dim strTemp1 As String
    Dim strTemp2 As String
    Dim lPos As Long
    Dim strTypeOfRequest As String
    Dim rsTemp As ADODB.Recordset
    Dim strSql As String
    
    
    On Error GoTo GetHeaderFromTextFix
    
    lPos = InStr(1, IdxVars.XMLString, "</Tracking>")
    If lPos <> 0 Then
        'get text up til end of header then close root node
        strHeader = Mid(IdxVars.XMLString, 1, lPos + 11)
        'remove version & dtd line
        lPos = InStr(1, strHeader, ".dtd") + 8
        If lPos > 0 Then
            'works if bus unti = 'LCB'
            'strTemp2 = Mid(strTemp1, lPos - 2, Len(strTemp1) - lPos)
            'works if bus unti = 'LCB01'
            strHeader = Mid(strHeader, lPos - 2, Len(strHeader))
        End If
        strTemp1 = strHeader
        'change KeyTax Type to "10" for error
        lPos = InStr(1, strTemp1, "<KeyTax Type=") + 13
        If lPos > 0 Then
            Select Case IdxVars.KeyTaxType
                Case "01", "03", "07", "08"
                Case Else
                    IdxVars.KeyTaxType = Mid(strTemp1, lPos + 1, 2)
            End Select
            strTemp1 = Mid(strTemp1, 1, lPos) & "" & "10" & """"
            strTemp1 = strTemp1 & Mid(strHeader, lPos + 4, Len(strHeader))
        End If
        'change the Request Status to "15" for error
        'lPos = InStr(1, strTemp1, "<RequestStatus Type=") + 20
        strSql = "Select MEANING from DIR_SYSTEM_CODES where VALUE = 15 and CODE = 'DIR_REQ_STATUS'"
        Set rsTemp = adoConn.Execute(strSql)
        If rsTemp.RecordCount <= 0 Then
            MsgBox "GetHeaderFromText: Data does not exist in the database: " & strSql
            GetHeaderFromText = ""
            Exit Function
        Else
            strTypeOfRequest = rsTemp!MEANING & "</RequestStatus>" & vbCrLf
        End If
        lPos = InStr(1, strTemp1, "RequestStatus") - 1
        If lPos > 0 Then
            strHeader = strTemp1
            strTemp1 = Trim(Left(strHeader, lPos + 13)) & ">"
            lPos = InStr(lPos, strHeader, "Company ID")
            strTemp2 = "<" & Mid(strHeader, lPos, Len(strHeader) - lPos)
        End If
        
        
        GetHeaderFromText = strTemp1 & strTypeOfRequest & strTemp2 & "</KeyTax>"
    Else
        GetHeaderFromText = ""
    End If
    
    Exit Function
    
GetHeaderFromTextFix:
    WriteToErr "GetHeaderFromText: " & Err.Number & " - " & Err.Description
    GetHeaderFromText = ""
End Function

Private Sub ClearIdxVars()

    'barb: start here
    'validation + "" and "NULL"
    'clean up
    'johan to write to created_date
    'sort out dtd location
    'remove all apostrophes from database data before inserting/updating

    IdxVars.InterfaceNo = 0
    IdxVars.XMLString = ""
    IdxVars.CreatedDated = ""
    IdxVars.SarsResponseYn = ""
    IdxVars.KeyTaxType = ""
    IdxVars.MqStatus = ""

    'Tracking Vars
    IdxVars.Tracking.MsgId = ""
    IdxVars.Tracking.ComId = ""
    IdxVars.Tracking.BuId = ""
    IdxVars.Tracking.ReferenceId = ""
    IdxVars.Tracking.ReqSeqNum = ""
    IdxVars.Tracking.RequestStatus = ""

    'Requestor Vars
    IdxVars.Request.Date = ""
    IdxVars.Request.Email = ""
    IdxVars.Request.Name = ""
    IdxVars.Request.Time = ""
    IdxVars.Request.UserId = ""

    'File Format Error Vars
    ErrVars.FormatErr.Code = ""
    ErrVars.FormatErr.Line = ""
    ErrVars.FormatErr.Reason = ""
    ErrVars.FormatErr.Text = ""

    'File Data Errors
    ErrVars.DataErr.DataErrText = ""
    
    'Other error vars
    ErrVars.InterfaceNo = 0
    ErrVars.ErrorType = ""


End Sub
''*---------------------------------------------------------------
''* Method:       LogError
''* Description:  Log error information to the error log XML file
''*               In addition, based on the error log mode, either
''*               email the error message, or display the error
''*               message details
''* Parameters:   oErr - A Visual Basic ErrObject
''* Returns:      Boolean - TRUE if succesful, FALSE otherwise
''* Comments:
''*---------------------------------------------------------------
'Public Function LogError(ByRef oErr As ErrObject) As Boolean
'  Dim sNow As String
'  Dim bResult As Boolean
'  Dim oXML As MSXML2.DOMDocument
'  Dim oRoot As MSXML2.IXMLDOMNode
'  Dim oNode As MSXML2.IXMLDOMNode
'  Dim oErrorNode As MSXML2.IXMLDOMNode
'  Dim oJMail As Object
'  Dim sLogFile As String
'  Dim lErrorNo As Long
'  Dim sErrorMessage As String
'  Dim sErrorSource As String
'  Dim sApp As String
'  Dim lErrorMode As Long
'  Dim sErrorEmailAddresses As String
'
'  With oErr
'    lErrorNo = .Number
'    sErrorMessage = .Description
'    sErrorSource = .Source
'  End With ' oErr
'
'  On Error GoTo PROC_ERROR
'
'  ' Don't report on repeating duplicate errors
'  If lErrorNo <> EmailVars.LastError Then
'
'    EmailVars.LastError = lErrorNo
'
'    With Globals.oSettings
'      sLogFile = .ErrorLogFile
'      lErrorMode = .ErrorLogMode
'      sErrorEmailAddresses = .ErrorEmailAddress
'    End With ' Globals.oSettings
'
'    sApp = basUtils.GetAppDetails
'    sNow = Format$(Now(), "DD-MM-YYYY HH:NN:SS")
'
'    ' Always write the error details to the XML error log
'    Call DebugMsg("Creating MSXML2.DOMDocument")
'    Set oXML = New MSXML2.DOMDocument
'
'    If (oXML.Load(sLogFile)) Then
'      ' Always log this error information to the error log XML
'      Set oRoot = oXML.selectSingleNode("ErrorLog")
'      Set oRoot = oRoot.selectSingleNode("Errors")
'      Set oNode = oXML.createNode(NODE_ELEMENT, "Error", "")
'      Set oErrorNode = oRoot.appendChild(oNode)
'
'      Set oNode = oXML.createAttribute("Date")
'      oNode.Text = sNow
'      Call oErrorNode.Attributes.setNamedItem(oNode)
'
'      Set oNode = oXML.createAttribute("ErrorNumber")
'      oNode.Text = "0x" & Hex$(lErrorNo)
'      Call oErrorNode.Attributes.setNamedItem(oNode)
'
'      Set oNode = oXML.createNode(NODE_CDATA_SECTION, "Message", "")
'      Set oNode = oErrorNode.appendChild(oNode)
'      oNode.Text = sErrorMessage
'      Set oNode = oXML.createNode(NODE_ELEMENT, "Source", "")
'      Set oNode = oErrorNode.appendChild(oNode)
'      oNode.Text = sErrorSource
'      Set oNode = oXML.createNode(NODE_ELEMENT, "App", "")
'      Set oNode = oErrorNode.appendChild(oNode)
'      oNode.Text = sApp
'
'      ' Update the error log
'      Call oXML.save(sLogFile)
'    End If ' If oXML.Load(sLogFile)
'
'    ' Send an error email to an email recipient
'    If lErrorMode = EErrorMode.EmailMessage Then
'      Call EMailErrorMessage( _
'        sErrorEmailAddresses, _
'        "EmailWorkstation Error", _
'        sApp & " has caused an error." & vbCrLf & vbCrLf & _
'        "<B>Date</B>: " & Format$(Now(), "dd/mm/yyyy Hh:Nn:Ss") & vbCrLf & _
'        "<B>Source</B>: " & sErrorSource & vbCrLf & _
'        "<B>Number</B>: " & Hex$(lErrorNo) & vbCrLf & vbCrLf & _
'        "<B>Error Message</B>: " & sErrorMessage & vbCrLf & vbCrLf & _
'        "<I>Please do not reply to this message as it has been automatically generated by " & sApp & "</I>")
'    End If ' lErrorMode And 4
'  End If ' If lErrorNo <> EmailVars.LastError
'
'  bResult = True
'
'PROC_EXIT:
'  Set oRoot = Nothing
'  Set oNode = Nothing
'  Set oXML = Nothing
'  Set oErrorNode = Nothing
'  Exit Function
'
'PROC_ERROR:
'  Call DebugMsg("LogError caused an error. " & Err.Description)
'  bResult = False
'  Err.Clear
'  Resume PROC_EXIT
'End Function ' LogError
'
'
'
'
